home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / TPHERS01.ARJ / TPHERSH.PAS < prev    next >
Pascal/Delphi Source File  |  1991-09-08  |  19KB  |  496 lines

  1. {*****************************************************************************}
  2. {*  A unit to manipulate the Hershey glyph (symbol) set.                     *}
  3. {*                                                                           *}
  4. {*  This code is donated to the Public domain.                               *}
  5. {*                                                                           *}
  6. {*  Dov Grobgeld                                                             *}
  7. {*  Department of Chemical Physics                                           *}
  8. {*  The Weizmann Institute of Science                                        *}
  9. {*  Israel                                                                   *}
  10. {*  Email: dov@menora.weizmann.ac.il                                         *}
  11. {*                                                                           *}
  12. {*  7/9/1991                                                                 *}
  13. {*                                                                           *}
  14. {*  Version 0.1beta                                                          *}
  15. {*                                                                           *}
  16. {*  There are only two dependances on BGI in this code, and both have the    *}
  17. {*  keywords 'BGI dependance' in comments beside them.                       *}
  18. {*****************************************************************************}
  19.  
  20. unit TPHersh;
  21.  
  22. interface
  23.  
  24. uses graph;   { BGI dependance }
  25.  
  26. {$ifopt n-} type double=real; {$endif}  { Use reals if no math coprocessor }
  27.  
  28. type
  29.   HersheyFont = array[#32..#127] of integer;
  30.   pHersheyFont = ^HersheyFont;
  31.  
  32. const
  33.   HersheyRomans : HersheyFont = (
  34.    699, 714, 717, 733, 719,2271, 734, 731, 721, 722,2219, 725, 711, 724, 710, 720,
  35.    700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 712, 713,2241, 726,2242, 715,
  36.   2273, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 511, 512, 513, 514, 515,
  37.    516, 517, 518, 519, 520, 521, 522, 523, 524, 525, 526,2223, 804,2224,2262, 999,
  38.    730, 601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615,
  39.    616, 617, 618, 619, 620, 621, 622, 623, 624, 625, 626,2225, 723,2226,2246, 718);
  40.  
  41. var
  42.   HersheyX, HersheyY                 : integer;
  43.   HersheyMaxX, HersheyAspectRatio    : double;
  44.  
  45. procedure HersheySetGlyphsFileName(s : string);
  46. procedure HersheyLoadGlyphs;
  47. procedure HersheyDisplayGlyph(GlyphNum : integer);
  48. procedure HersheyOutTextXY(x,y : integer; s : string);
  49. procedure HersheyOutText(s : string);
  50. procedure HersheySetGlyphSize(xs, ys: double);
  51. procedure HersheyDisposeFont;
  52. procedure HersheySetFont(var pFont);
  53. procedure HersheyMove(x,y : integer);
  54. function HersheyGlyphWidth(GlyphNum : integer) : double;
  55. function HersheyStringWidth(s : string) : double;
  56. procedure HersheySetAngle(theta : double);
  57. procedure HersheySetStringJustify(Horizontal, Vertical : integer);
  58.  
  59. implementation
  60.  
  61. const
  62.   MaxHersheyChars = 3999;
  63.   MaxStrokes = 1000;
  64.  
  65. type
  66.   {*****************************************************************************}
  67.   {* The strokes in a character are stored in the file as integers represented *}
  68.   {* as characters centered around 'R'.                                        *}
  69.   {*                                                                           *}
  70.   {* All characters are drawn around the center of the character. The width    *}
  71.   {* of the charecter is decided by +-Stroke[0] and the height is determined   *}
  72.   {* by +-Stroke[1].                                                           *}
  73.   {*****************************************************************************}
  74.   StrokeVector = array[1..MaxStrokes-1] of char;
  75.   pStrokeVector = ^StrokeVector;
  76.   HersheyChar  = record
  77.     numStrokes : byte;
  78.     pStroke    : pStrokeVector;
  79.   end;
  80.   HersheyFontType = array[1..MaxHersheyChars] of ^HersheyChar;
  81.  
  82. const
  83.   HersheyGlyphsFileName : string = 'hersh.hfn';
  84.  
  85. var
  86.   HersheyFontArray    : ^HersheyFontType;
  87.   HersheyCurrentFont  : ^HersheyFont;
  88.   SinTheta, CosTheta : double;       { Rotation of character }
  89.   xiScale, nuScale      : double;
  90.   HStringJust, VStringJust : double;
  91.  
  92.  
  93. {*****************************************************************************}
  94. {*  Allows the user to chose another font file.                              *}
  95. {*****************************************************************************}
  96. procedure HersheySetGlyphsFileName(s : string);
  97. begin
  98.   HersheyGlyphsFileName:= s;
  99. end;
  100.  
  101. {*****************************************************************************}
  102. {*  FAST block read routines to read the font...                             *}
  103. {*****************************************************************************}
  104. CONST
  105.   BufLen = 8192;
  106.  
  107. TYPE
  108.   RecType = char;
  109.   ArrayRecType=Array[1..BufLen] of RecType;
  110.  
  111. VAR
  112.   FontFile                    : FILE;
  113.   InBuf                       : ^arrayRecType;
  114.   InPtr                       : WORD;
  115.   RecRead                     : WORD;
  116.  
  117. procedure OpenBlockFiles(p : pointer);
  118. begin
  119.   { Open the font file for unformated input }
  120.   Assign(FontFile, HersheyGlyphsFileName);   Reset(FontFile, SizeOf(RecType));
  121.   RecRead:= 0;
  122.   InPtr:= RecRead + 1;
  123.   InBuf:= p;
  124. end;
  125.  
  126. procedure CloseBlockFiles;
  127. begin
  128.   close(FontFile);
  129. end;
  130.  
  131. FUNCTION GetNextRec(VAR _rec; NumRecs : integer): BOOLEAN;
  132. var
  133.   rec: ArrayRecType absolute _rec;
  134.   RecOfs : integer;
  135. BEGIN
  136.   if NumRecs + InPtr <= Recread then begin
  137.     move(InBuf^[InPtr], rec[1], NumRecs * sizeof(RecType));
  138.     InPtr:= InPtr + NumRecs;
  139.     GetNextRec:= TRUE;
  140.   end
  141.   else begin
  142.     if RecRead >= InPtr then begin
  143.       move(InBuf^[InPtr], rec[1], (RecRead-InPtr+1) * sizeof(RecType));
  144.       RecOfs:= RecRead - InPtr + 1;
  145.     end
  146.     else RecOfs:= 0;
  147.     BlockRead(FontFile, InBuf^, BufLen, RecRead);
  148.     IF RecRead = 0 THEN BEGIN
  149.       GetNextRec:= FALSE;
  150.       Exit;
  151.     END;
  152.     InPtr:= 1;
  153.     move(InBuf^[InPtr], rec[RecOfs+1], (NumRecs - RecOfs) * sizeof(RecType));
  154.     InPtr:= InPtr + NumRecs - RecOfs;
  155.   end;
  156. END;
  157.  
  158. {*****************************************************************************}
  159. {*  Load the font into memory.                                               *}
  160. {*****************************************************************************}
  161. procedure HersheyLoadGlyphs;
  162. var
  163.   numString : string[5];
  164.   i       : integer;
  165.   GlyphNum, numStrokes : integer;
  166.   errPos  : integer;
  167.   Buf     : array[1..BufLen] of byte;
  168.   crlf    : array[1..2] of char;
  169.   eofFlag : boolean;
  170. label
  171.   exitLoad;
  172.  
  173.   function imin(a,b : integer): integer;
  174.   begin
  175.     if a<b then imin:= a
  176.     else imin:= b;
  177.   end;
  178.  
  179. begin
  180.   if HersheyFontArray=nil then begin
  181.     new(HersheyFontArray);
  182.  
  183.     { Zero all characters }
  184.     for i:= 1 to MaxHersheyChars do HersheyFontArray^[i]:= nil;
  185.   end;
  186.  
  187.   openBlockFiles(@Buf);  { Let's use a stack buffer instead of a heap buffer... }
  188.  
  189.   eofFlag:= false;
  190.   while not eofFlag do begin
  191.  
  192.     { Get the Hershey Glyph number and the number of strokes in the font }
  193.     numString[0]:= #5;
  194.     eofFlag:= not GetNextRec(numString[1],5);
  195.     val(numString, GlyphNum, errPos);
  196.  
  197.     numString[0]:= #3;
  198.     eofFlag:= not GetNextRec(numString[1],3);
  199.     val(numString, numStrokes, errPos);
  200.  
  201.     if eofFlag then goto ExitLoad;
  202.  
  203.     { Allocate the memory for the character and store it}
  204.     if HersheyFontArray^[GlyphNum] = nil then begin
  205.       new(HersheyFontArray^[GlyphNum]);
  206.       HersheyFontArray^[GlyphNum]^.numStrokes:= numStrokes;
  207.       GetMem(HersheyFontArray^[GlyphNum]^.pStroke, numStrokes * 2);
  208.  
  209.       { Copy all the characters... }
  210.       eofFlag:= not GetNextRec(HersheyFontArray^[GlyphNum]^.pStroke^[1], 2*numStrokes);
  211.       if not eofFlag then eofFlag:= not GetNextRec(crlf[1], 2);  { Get CR, LF }
  212.       if ((crlf[1] <> #13) or (crlf[2] <> #10)) then begin
  213.         writeln('Warning at character ', GlyphNum, '. Expected cr/lf not found! ');
  214.         writeln('Searching for next cr/lf...');
  215.         repeat
  216.           eofFlag:= not GetNextRec(crlf[1],1);
  217.           if not eofFlag and (crlf[1]=#13) then eofFlag:= not GetNextRec(crlf[2],1);
  218.         until ((crlf[1] = #13) and (crlf[2] = #10)) or eofFlag;
  219.       end;
  220.     end;
  221.   end;
  222.  
  223. ExitLoad:
  224.   CloseBlockFiles;
  225. end;
  226.  
  227. {*****************************************************************************}
  228. {*  Throw away the font from memory.                                         *}
  229. {*****************************************************************************}
  230. procedure HersheyDisposeFont;
  231. var
  232.   i: integer;
  233. begin
  234.   for i:= 1 to MaxHersheyChars do begin
  235.     if HersheyFontArray^[i] <> nil then begin
  236.       freemem(HersheyFontArray^[i]^.pStroke,HersheyFontArray^[i]^.numStrokes * 2);
  237.       dispose(HersheyFontArray^[i]);
  238.       HersheyFontArray^[i]:= nil;
  239.     end;
  240.   end;
  241.   Dispose(HersheyFontArray);
  242.   HersheyFontArray:= nil;
  243. end;
  244.  
  245. {****************************************************************************}
  246. {*  HersheyDraw draws a line from the current Hershey line position to the  *}
  247. {*  position x,y.                                                           *}
  248. {*                                                                          *}
  249. {*  The only system dependent routine. This routine calls the line routine  *}
  250. {*  from the BGI toolkit. It can easily be exchanged to another routine on  *}
  251. {*  any desired device.                                                     *}
  252. {****************************************************************************}
  253. procedure HersheyDraw(x,y : integer);
  254. begin
  255.   Line(HersheyX,HersheyY,x,y);      { BGI dependance }
  256.  
  257.   HersheyX:= X; HersheyY:= Y;
  258. end;
  259.  
  260. {****************************************************************************}
  261. {*  Sets the new Hershey current position to x,y                            *}
  262. {****************************************************************************}
  263. procedure HersheyMove(x,y : integer);
  264. begin
  265.   HersheyX:= x; HersheyY:= y;
  266. end;
  267.  
  268. {****************************************************************************}
  269. {*  Displays Glyph GlyphNum at the current position in the current size      *}
  270. {*  and rotation. It updates the Hershey current position to fit for the    *}
  271. {*  next character.                                                         *}
  272. {****************************************************************************}
  273. procedure HersheyDisplayGlyph(GlyphNum : integer);
  274. var
  275.   skip : boolean;
  276.   i : integer;
  277.   xint, yint : integer;
  278.   xi, nu       : integer; { Internal vectors of character }
  279.   dxi, dnu : integer;     { Height and width information of character }
  280.   charX, charY : integer; { Position of the current character }
  281. begin
  282.   { Check if the character is valid }
  283.   if (GlyphNum < 1) or (GlyphNum > maxHersheyChars) then exit;
  284.   if HersheyFontArray^[GlyphNum]= nil then exit;
  285.   
  286.   charX:= HersheyX; charY:= HersheyY; { Get current character position }
  287.   HersheyMove(charX, charY);
  288.   skip:= true;
  289.   
  290.   with HersheyFontArray^[GlyphNum]^ do begin
  291.     { Save the width information of the character }
  292.     dxi:= ord(pStroke^[1]) - ord('R');
  293.     dnu:= ord(pStroke^[2]) - ord('R');
  294.  
  295.     { Move to the center of the character }
  296.     charX:= charX - round(dxi*xiScale*cosTheta) { + round(GlyphHeightJustType * FontHeight * yScale * sinTheta)) };
  297.     charY:= charY + round(dxi*xiScale*sinTheta) { + round(GlyphHeightJustType * FontHeight * yScale * cosTheta)) };
  298.  
  299.     for i:= 2 to numStrokes do begin
  300.       if pStroke^[i*2-1] = ' ' then skip:= true
  301.       else begin
  302.         xint:= ord(pStroke^[i*2-1]) - ord('R');
  303.         yint:= ord(pStroke^[i*2  ]) - ord('R');
  304.         if skip then begin
  305.           skip:= false;
  306.           HersheyMove(charX + round(xint * xiScale * cosTheta + yint * nuScale * sinTheta),
  307.                       charY + round(-xint * xiScale * sinTheta + yint * nuScale * cosTheta));
  308.         end
  309.         else
  310.           HersheyDraw(charX + round(xint * xiScale * cosTheta + yint * nuScale * sinTheta),
  311.                       charY + round(-xint * xiScale * sinTheta + yint * nuScale * cosTheta));
  312.       end;
  313.     end;
  314.  
  315.     { Move to the right side of the character }
  316.     charX:= charX - round(dxi*xiScale*cosTheta);
  317.     charY:= charY + round(dxi*xiScale*sinTheta);
  318.     HersheyMove(charX, charY);
  319.   end;
  320. end;
  321.  
  322. {****************************************************************************}
  323. {*  Change the current Hershey font.                                        *}
  324. {****************************************************************************}
  325. procedure HersheySetFont(var pFont);
  326. begin
  327.   HersheyCurrentFont:= @pFont;
  328. end;
  329.  
  330. {****************************************************************************}
  331. {*  Set the font rotation angle.                                            *}
  332. {****************************************************************************}
  333. procedure HersheySetAngle(theta : double);
  334. begin
  335.   SinTheta:= sin(theta/180*pi);
  336.   CosTheta:= cos(theta/180*pi);
  337. end;
  338.  
  339. {***************************************************************************}
  340. {*  Sets the width and the height of the characters.                       *}
  341. {*  The size is given in Percent of the external Hershey character box     *}
  342. {*  with respect to the maximal xposition.                                 *}
  343. {*                                                                         *}
  344. {*  Note that most characters don't fill their character boxes and thus    *}
  345. {*  will be much smaller than what might be believed.                      *}
  346. {*                                                                         *}
  347. {*  Also note that both the hight and width (xi and nu in the character    *}
  348. {*  coordinates) are given in terms of percent of the maximal x value.     *}
  349. {*  The aspect ratio can be modified by the value of HersheyAspectRatio.   *}
  350. {***************************************************************************}
  351. procedure HersheySetGlyphSize(xs, ys: double);
  352. begin
  353.   xiScale:= xs/100*HersheyMaxX/100;
  354.   nuScale:= ys/100*HersheyMaxX * HersheyAspectRatio/100;
  355. end;
  356.  
  357. {***************************************************************************}
  358. {*  Sets the maximum x value and the aspect ration which are used in the   *}
  359. {*  calculation of the Glyph size.                                         *}
  360. {***************************************************************************}
  361. procedure HersheySetMaxX(maxX, aspectRatio: double);
  362. begin
  363.   HersheyMaxX:= maxX;
  364.   HersheyAspectRatio:= aspectRatio;
  365. end;
  366.  
  367. {***************************************************************************}
  368. {*  Returns the width of a Glyph.                                         *}
  369. {***************************************************************************}
  370. function HersheyGlyphWidth(GlyphNum : integer) : double;
  371. begin
  372.   if HersheyFontArray^[GlyphNum]=nil then begin
  373.     HersheyGlyphWidth:= 0;
  374.     exit;
  375.   end;
  376.   HersheyGlyphWidth:= xiScale * -2 * (ord(HersheyFontArray^[GlyphNum]^.pStroke^[1]) - ord('R'));
  377. end;
  378.  
  379. {***************************************************************************}
  380. {*  Returns the height of a glyph.                                         *}
  381. {***************************************************************************}
  382. function HersheyGlyphHeight(GlyphNum : integer) : double;
  383. begin
  384.   if HersheyFontArray^[GlyphNum]=nil then begin
  385.     HersheyGlyphHeight:= 0;
  386.     exit;
  387.   end;
  388.   HersheyGlyphHeight:= nuScale * 2 * (ord(HersheyFontArray^[GlyphNum]^.pStroke^[2]) - ord('R'));
  389. end;
  390.  
  391. {***************************************************************************}
  392. {*  Returns the width of a string in the current font...                   *}
  393. {***************************************************************************}
  394. function HersheyStringWidth(s : string) : double;
  395. var
  396.   sum : double;
  397.   i : integer;
  398. begin
  399.   sum:= 0;
  400.   for i:= 1 to length(s) do sum:= sum + HersheyGlyphWidth(HersheyCurrentFont^[s[i]]);
  401.   HersheyStringWidth:= sum;
  402. end;
  403.  
  404. {**************************************************************************}
  405. {*  How to justify a string.                                              *}
  406. {*                                                                        *}
  407. {*    -1 : left, bot justification                                        *}
  408. {*     0 : middle, centre justification                                   *}
  409. {*     1 : left top justification                                         *}
  410. {**************************************************************************}
  411. procedure HersheySetStringJustify(horizontal, vertical : integer);
  412. begin
  413.   HStringJust:= Horizontal;
  414.   VStringJust:= Vertical;
  415. end;
  416.  
  417. {****************************************************************************}
  418. {*  Write the string s at the current Hershey pen position in the current   *}
  419. {*  string justification.                                                   *}
  420. {****************************************************************************}
  421. procedure HersheyOutText(s : string);
  422. var
  423.   i : integer;
  424.   stringWidth, stringHeight : integer;
  425.   dx, dy : integer;
  426.   x, y : integer;
  427.   d: double;
  428. begin
  429.   x:= HersheyX; y:= HersheyY;
  430.   if HStringJust<> -1 then begin
  431.     d:= HersheyStringWidth(s);
  432.     stringWidth:= round(HersheyStringWidth(s));
  433.     dx:= round(stringWidth * cosTheta);
  434.     dy:= round(stringWidth * sinTheta);
  435.     if HStringJust=0 then begin
  436.       x:= x - dx div 2;
  437.       y:= y - dy div 2;
  438.     end
  439.     else begin
  440.       x:= x - dx;
  441.       y:= y - dy;
  442.     end;
  443.   end;
  444.   if VStringJust <> 0 then begin
  445.     stringHeight:= round(HersheyGlyphHeight(HersheyCurrentFont^['A']));
  446.     dx:= round(StringHeight * sinTheta);
  447.     dy:= round(StringHeight * cosTheta);
  448.     if VStringJust= 1 then begin
  449.       dx:= - dx div 2;
  450.       dy:= dy div 2;
  451.     end
  452.     else begin
  453.       dx:= dx div 2;
  454.       dy:= - dy div 2;
  455.     end;
  456.     x:= x+dx;
  457.     y:= y+dy;
  458.   end
  459.   else begin
  460.     dx:= 0;
  461.     dy:= 0;
  462.   end;
  463.  
  464.   HersheyMove(x,y);
  465.   for i:= 1 to length(s) do
  466.     HersheyDisplayGlyph(HersheyCurrentFont^[s[i]]);
  467.   
  468.   { Move the pen pointer back to compensate for vertical justification }
  469.   if dx+dy <> 0 then HersheyMove(HersheyX-dx,HersheyY-dy);
  470. end;
  471.  
  472. {****************************************************************************}
  473. {*  Like HersheyOutText, but writes the string at the position (x,y).       *}
  474. {****************************************************************************}
  475. procedure HersheyOutTextXY(x,y : integer; s : string);
  476. var
  477.   i : integer;
  478. begin
  479.   HersheyMove(x,y);
  480.   HersheyOutText(s);
  481. end;
  482.  
  483. {****************************************************************************}
  484. {* Unit body. Initialize the parameters.                                    *}
  485. {****************************************************************************}
  486. begin
  487.   HersheyMove(0,0);
  488.   HersheyFontArray:= nil;
  489.   HersheySetFont(HersheyRomanS);
  490.   HersheySetGlyphSize(5,5);
  491.   HersheySetAngle(0);
  492.   HersheySetStringJustify(-1,0);
  493.   HersheySetMaxX(640,1);
  494. end.
  495.  
  496.